home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / print.d < prev    next >
Encoding:
Text File  |  1994-05-07  |  41.6 KB  |  2,033 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19. */
  20.  
  21. /*
  22.     print.d
  23. */
  24.  
  25. #include "include.h"
  26. #include "mp.h"
  27. #define LINE_LENGTH line_length
  28. static line_length = 72;
  29.  
  30. #ifndef WRITEC_NEWLINE
  31. #define  WRITEC_NEWLINE(strm) (writec_stream('\n',strm))
  32. #endif
  33.  
  34. #define    to_be_escaped(c) \
  35.     (standard_readtable->rt.rt_self[(c)&0377].rte_chattrib \
  36.      != cat_constituent || \
  37.      isLower((c)&0377) || (c) == ':')
  38.  
  39.  
  40.  
  41. object siVprint_package;
  42. object siVprint_structure;
  43.  
  44.  
  45. /* bool RPINcircle; ??typo?? */
  46.  
  47.  
  48. bool PRINTpackage;
  49. bool PRINTstructure;
  50.  
  51. #define    write_ch    (*write_ch_fun)
  52.  
  53.  
  54. #define    MARK        0400
  55. #define    UNMARK        0401
  56. #define    SET_INDENT    0402
  57. #define    INDENT        0403
  58. #define    INDENT1        0404
  59. #define    INDENT2        0405
  60.  
  61. #define    Q_SIZE        128
  62. #define IS_SIZE        256
  63.  
  64. #define    mod(x)        ((x)%Q_SIZE)
  65.  
  66. static short queue[Q_SIZE];
  67. static short indent_stack[IS_SIZE];
  68.  
  69. static int qh;
  70. static int qt;
  71. static int qc;
  72. static int isp;
  73. static int iisp;
  74.  
  75. writec_queue(c)
  76. int c;
  77. {
  78.     if (qc >= Q_SIZE)
  79.         flush_queue(FALSE);
  80.     if (qc >= Q_SIZE)
  81.         FEerror("Can't pretty-print.", 0);
  82.     queue[qt] = c;
  83.     qt = mod(qt+1);
  84.     qc++;
  85. }
  86.  
  87. flush_queue(force)
  88. {
  89.     int c, i, j, k, l, i0;
  90.  
  91. BEGIN:
  92.     while (qc > 0) {
  93.         c = queue[qh];
  94.         if (c == MARK)
  95.             goto DO_MARK;
  96.         else if (c == UNMARK)
  97.             isp -= 2;
  98.         else if (c == SET_INDENT)
  99.             indent_stack[isp] = file_column(PRINTstream);
  100.         else if (c == INDENT) {
  101.             goto DO_INDENT;
  102.         } else if (c == INDENT1) {
  103.             i = file_column(PRINTstream)-indent_stack[isp];
  104.             if (i < 8 && indent_stack[isp] < LINE_LENGTH/2) {
  105.                 writec_stream(' ', PRINTstream);
  106.                 indent_stack[isp]
  107.                 = file_column(PRINTstream);
  108.             } else {
  109.                 if (indent_stack[isp] < LINE_LENGTH/2) {
  110.                     indent_stack[isp]
  111.                     = indent_stack[isp-1] + 4;
  112.                 }
  113.                 goto DO_INDENT;
  114.             }
  115.         } else if (c == INDENT2) {
  116.             indent_stack[isp] = indent_stack[isp-1] + 2;
  117.             goto PUT_INDENT;
  118.         } else if (c < 0400)
  119.             writec_stream(c, PRINTstream);
  120.         qh = mod(qh+1);
  121.         --qc;
  122.     }
  123.     return;
  124.  
  125. DO_MARK:
  126.     k = LINE_LENGTH - 1 - file_column(PRINTstream);
  127.     for (i = 1, j = 0, l = 1;  l > 0 && i < qc && j < k;  i++) {
  128.         c = queue[mod(qh + i)];
  129.         if (c == MARK)
  130.             l++;
  131.         else if (c == UNMARK)
  132.             --l;
  133.         else if (c == INDENT || c == INDENT1 || c == INDENT2)
  134.             j++;
  135.         else if (c < 0400)
  136.             j++;
  137.     }
  138.     if (l == 0)
  139.         goto FLUSH;
  140.     if (i == qc && !force)
  141.         return;
  142.     qh = mod(qh+1);
  143.     --qc;
  144.     if (++isp >= IS_SIZE-1)
  145.         FEerror("Can't pretty-print.", 0);
  146.     indent_stack[isp++] = file_column(PRINTstream);
  147.     indent_stack[isp] = indent_stack[isp-1];
  148.     goto BEGIN;
  149.  
  150. DO_INDENT:
  151.     if (iisp > isp)
  152.         goto PUT_INDENT;
  153.     k = LINE_LENGTH - 1 - file_column(PRINTstream);
  154.     for (i0 = 0, i = 1, j = 0, l = 1;  i < qc && j < k;  i++) {
  155.         c = queue[mod(qh + i)];
  156.         if (c == MARK)
  157.             l++;
  158.         else if (c == UNMARK) {
  159.             if (--l == 0)
  160.                 goto FLUSH;
  161.         } else if (c == SET_INDENT) {
  162.             if (l == 1)
  163.                 break;
  164.         } else if (c == INDENT) {
  165.             if (l == 1)
  166.                 i0 = i;
  167.             j++;
  168.         } else if (c == INDENT1) {
  169.             if (l == 1)
  170.                 break;
  171.             j++;
  172.         } else if (c == INDENT2) {
  173.             if (l == 1) {
  174.                 i0 = i;
  175.                 break;
  176.             }
  177.             j++;
  178.         } else if (c < 0400)
  179.             j++;
  180.     }
  181.     if (i == qc && !force)
  182.         return;
  183.     if (i0 == 0)
  184.         goto PUT_INDENT;
  185.     i = i0;
  186.     goto FLUSH;
  187.  
  188. PUT_INDENT:
  189.     qh = mod(qh+1);
  190.     --qc;
  191.     
  192.         WRITEC_NEWLINE(PRINTstream);
  193.     for (i = indent_stack[isp];  i > 0;  --i)
  194.         writec_stream(' ', PRINTstream);
  195.     iisp = isp;
  196.     goto BEGIN;
  197.  
  198. FLUSH:
  199.     for (j = 0;  j < i;  j++) {
  200.         c = queue[qh];
  201.         if (c == INDENT || c == INDENT1 || c == INDENT2)
  202.             writec_stream(' ', PRINTstream);
  203.         else if (c < 0400)
  204.             writec_stream(c, PRINTstream);
  205.         qh = mod(qh+1);
  206.         --qc;
  207.     }
  208.     goto BEGIN;
  209. }
  210.  
  211. writec_PRINTstream(c)
  212. int c;
  213. {
  214.     if (c == INDENT || c == INDENT1)
  215.         writec_stream(' ', PRINTstream);
  216.     else if (c < 0400)
  217.         writec_stream(c, PRINTstream);
  218. }
  219.  
  220. write_str(s)
  221. char *s;
  222. {
  223.     while (*s != '\0')
  224.         write_ch(*s++);
  225. }
  226.  
  227. write_decimal(i)
  228. int i;
  229. {
  230.     if (i == 0) {
  231.         write_ch('0');
  232.         return;
  233.     }
  234.     write_decimal1(i);
  235. }
  236.  
  237. write_decimal1(i)
  238. int i;
  239. {
  240.     if (i == 0)
  241.         return;
  242.     write_decimal1(i/10);
  243.     write_ch(i%10 + '0');
  244. }
  245.  
  246. write_addr(x)
  247. object x;
  248. {
  249.     int i, j, k;
  250.  
  251.     i = (int)x;
  252.     for (j = 28;  j >= 0;  j -= 4) {
  253.         k = (i>>j) & 0xf;
  254.         if (k < 10)
  255.             write_ch('0' + k);
  256.         else
  257.             write_ch('a' + k - 10);
  258.     }
  259. }
  260.  
  261. write_base()
  262. {
  263.     if (PRINTbase == 2)
  264.         write_str("#b");
  265.     else if (PRINTbase == 8)
  266.         write_str("#o");
  267.     else if (PRINTbase == 16)
  268.         write_str("#x");
  269.     else if (PRINTbase >= 10) {
  270.         write_ch('#');
  271.         write_ch(PRINTbase/10+'0');
  272.         write_ch(PRINTbase%10+'0');
  273.         write_ch('r');
  274.     } else {
  275.         write_ch('#');
  276.         write_ch(PRINTbase+'0');
  277.         write_ch('r');
  278.     }
  279. }
  280.  
  281. /* The floating point precision required to make the most-positive-long-float
  282.    printed expression readable.   If this is too small, then the rounded
  283.    off fraction, may be too big to read */
  284.  
  285. #ifndef FPRC 
  286. #define FPRC 16
  287. #endif
  288.  
  289. object siLprint_nans;
  290.  
  291. edit_double(n, d, sp, s, ep)
  292. int n;
  293. double d;
  294. char *s;
  295. int *sp;
  296. int *ep;
  297. {
  298.     char *p, buff[FPRC + 9];
  299.     int i;
  300.  
  301. #ifdef IEEEFLOAT
  302.     if ((*((int *)&d +HIND) & 0x7ff00000) == 0x7ff00000)
  303.            {if (siLprint_nans->s.s_dbind !=Cnil)
  304.           {sprintf(s, "%e",d);
  305.            *sp = 2;
  306.            return;
  307.          }
  308.        else
  309.         FEerror("Can't print a non-number.",
  310.             0);}
  311.     else
  312.         sprintf(buff, "%*.*e",FPRC+8,FPRC, d);
  313.     if (buff[FPRC+3] != 'e') {
  314.         sprintf(buff, "%*.*e",FPRC+7,FPRC,d);
  315.         *ep = (buff[FPRC+5]-'0')*10 + (buff[FPRC+6]-'0');
  316.     } else
  317.         *ep = (buff[FPRC+5]-'0')*100 +
  318.           (buff[FPRC+6]-'0')*10 + (buff[FPRC+7]-'0');
  319.     *sp = 1;
  320.     if (buff[0] == '-')
  321.         *sp *= -1;
  322. #else
  323.     sprintf(buff, "%*.*e",FPRC+7,FPRC, d);
  324.     /*  "-D.MMMMMMMMMMMMMMMe+EE"  */
  325.     /*   0123456789012345678901   */
  326.     *sp = 1;
  327.     if (buff[0] == '-')
  328.         *sp *= -1;
  329.     *ep = (buff[FPRC+5]-'0')*10 + (buff[FPRC+6]-'0');
  330. #endif
  331.  
  332.     if (buff[FPRC+4] == '-')
  333.         *ep *= -1;
  334.     buff[2] = buff[1];
  335.     p = buff + 2;
  336.     if (n < FPRC+1) {
  337.         if (p[n] >= '5') {
  338.             for (i = n - 1;  i >= 0;  --i)
  339.                 if (p[i] == '9')
  340.                     p[i] = '0';
  341.                 else {
  342.                     p[i]++;
  343.                     break;
  344.                 }
  345.             if (i < 0) {
  346.                 *--p = '1';
  347.                 (*ep)++;
  348.             }
  349.         }
  350.         for (i = 0;  i < n;  i++)
  351.             s[i] = p[i];
  352.     } else {
  353.         for (i = 0;  i < FPRC+1;  i++)
  354.             s[i] = p[i];
  355.         for (;  i < n;  i++)
  356.             s[i] = '0';
  357.     }
  358.     s[n] = '\0';
  359. }
  360.  
  361. write_double(d, e, shortp)
  362. double d;
  363. int e;
  364. bool shortp;
  365. {
  366.     int sign;
  367.     char buff[FPRC+5];
  368.     int exp;
  369.     int i;
  370.     int n = FPRC+1;
  371.  
  372.     if (shortp)
  373.         n = 7;
  374.     edit_double(n, d, &sign, buff, &exp);
  375.     if (sign==2) {write_str("#<");
  376.               write_str(buff);
  377.               write_ch('>');
  378.               return;
  379.             }
  380.     if (sign < 0)
  381.         write_ch('-');
  382.     if (-3 <= exp && exp < 7) {
  383.         if (exp < 0) {
  384.             write_ch('0');
  385.             write_ch('.');
  386.             exp = (-exp) - 1;
  387.             for (i = 0;  i < exp;  i++)
  388.                 write_ch('0');
  389.             for (;  n > 0;  --n)
  390.                 if (buff[n-1] != '0')
  391.                     break;
  392.             if (exp == 0 && n == 0)
  393.                 n = 1;
  394.             for (i = 0;  i < n;  i++)
  395.                 write_ch(buff[i]);
  396.         } else {
  397.             exp++;
  398.             for (i = 0;  i < exp;  i++)
  399.                 if (i < n)
  400.                     write_ch(buff[i]);
  401.                 else
  402.                     write_ch('0');
  403.             write_ch('.');
  404.             if (i < n)
  405.                 write_ch(buff[i]);
  406.             else
  407.                 write_ch('0');
  408.             i++;
  409.             for (;  n > i;  --n)
  410.                 if (buff[n-1] != '0')
  411.                     break;
  412.             for (;  i < n;  i++)
  413.                 write_ch(buff[i]);
  414.         }
  415.         exp = 0;
  416.     } else {
  417.         write_ch(buff[0]);
  418.         write_ch('.');
  419.         write_ch(buff[1]);
  420.         for (;  n > 2;  --n)
  421.             if (buff[n-1] != '0')
  422.                 break;
  423.         for (i = 2;  i < n;  i++)
  424.             write_ch(buff[i]);
  425.     }
  426.     if (exp == 0 && e == 0)
  427.         return;
  428.     if (e == 0)
  429.         e = 'E';
  430.     write_ch(e);
  431.     if (exp < 0) {
  432.         write_ch('-');
  433.         exp *= -1;
  434.     }
  435.     write_decimal(exp);
  436. }
  437.  
  438. call_structure_print_function(x, level)
  439. object x;
  440. int level;
  441. {
  442.     int i;
  443.     bool eflag;
  444.     bds_ptr old_bds_top;
  445.  
  446.     int (*wf)() = write_ch_fun;
  447.  
  448.     object *vt = PRINTvs_top;
  449.     object *vl = PRINTvs_limit;
  450.     bool e = PRINTescape;
  451.     bool r = PRINTradix;
  452.     int b = PRINTbase;
  453.     bool c = PRINTcircle;
  454.     bool p = PRINTpretty;
  455.     int lv = PRINTlevel;
  456.     int ln = PRINTlength;
  457.     bool g = PRINTgensym;
  458.     bool a = PRINTarray;
  459.  
  460. /*
  461.     short oq[Q_SIZE];
  462. */
  463.     short ois[IS_SIZE];
  464.  
  465.     int oqh;
  466.     int oqt;
  467.     int oqc;
  468.     int oisp;
  469.     int oiisp;
  470.  
  471. ONCE_MORE:
  472.     if (interrupt_flag) {
  473.         interrupt_flag = FALSE;
  474. #ifdef UNIX
  475.         alarm(0);
  476. #endif
  477.         terminal_interrupt(TRUE);
  478.         goto ONCE_MORE;
  479.     }
  480.  
  481.     if (PRINTpretty)
  482.         flush_queue(TRUE);
  483.  
  484.     oqh = qh;
  485.     oqt = qt;
  486.     oqc = qc;
  487.     oisp = isp;
  488.     oiisp = iisp;
  489.  
  490. /*    No need to save the queue, since it is flushed.
  491.     for (i = 0;  i < Q_SIZE;  i++)
  492.         oq[i] = queue[i];
  493. */
  494.     for (i = 0;  i <= isp;  i++)
  495.         ois[i] = indent_stack[i];
  496.  
  497.     vs_push(PRINTstream);
  498.     vs_push(PRINTcase);
  499.  
  500.     vs_push(make_fixnum(level));
  501.  
  502.     old_bds_top = bds_top;
  503.     bds_bind(Vprint_escape, PRINTescape?Ct:Cnil);
  504.     bds_bind(Vprint_radix, PRINTradix?Ct:Cnil);
  505.     bds_bind(Vprint_base, make_fixnum(PRINTbase));
  506.     bds_bind(Vprint_circle, PRINTcircle?Ct:Cnil);
  507.     bds_bind(Vprint_pretty, PRINTpretty?Ct:Cnil);
  508.     bds_bind(Vprint_level, PRINTlevel<0?Cnil:make_fixnum(PRINTlevel));
  509.     bds_bind(Vprint_length, PRINTlength<0?Cnil:make_fixnum(PRINTlength));
  510.     bds_bind(Vprint_gensym, PRINTgensym?Ct:Cnil);
  511.     bds_bind(Vprint_array, PRINTarray?Ct:Cnil);
  512.     bds_bind(Vprint_case, PRINTcase);
  513.  
  514.     frs_push(FRS_PROTECT, Cnil);
  515.     if (nlj_active) {
  516.         eflag = TRUE;
  517.         goto L;
  518.     }
  519.  
  520.     ifuncall3(S_DATA(x->str.str_def)->print_function,
  521.           x, PRINTstream, vs_head);
  522.     vs_pop;
  523.     eflag = FALSE;
  524.  
  525. L:
  526.     frs_pop();
  527.     bds_unwind(old_bds_top);
  528.  
  529. /*
  530.     for (i = 0;  i < Q_SIZE;  i++)
  531.         queue[i] = oq[i];
  532. */
  533.     for (i = 0;  i <= oisp;  i++)
  534.         indent_stack[i] = ois[i];
  535.  
  536.     iisp = oiisp;
  537.     isp = oisp;
  538.     qc = oqc;
  539.     qt = oqt;
  540.     qh = oqh;
  541.  
  542.     PRINTcase = vs_pop;
  543.     PRINTstream = vs_pop;
  544.     PRINTarray = a;
  545.     PRINTgensym = g;
  546.     PRINTlength = ln;
  547.     PRINTlevel = lv;
  548.     PRINTpretty = p;
  549.     PRINTcircle = c;
  550.     PRINTbase = b;
  551.     PRINTradix = r;
  552.     PRINTescape = e;
  553.     PRINTvs_limit = vl;
  554.     PRINTvs_top = vt;
  555.  
  556.     write_ch_fun = wf;
  557.  
  558.     if (eflag) {
  559.         nlj_active = FALSE;
  560.         unwind(nlj_fr, nlj_tag);
  561.     }
  562. }
  563. object copy_big();
  564.  
  565. write_object(x, level)
  566. object x;
  567. int level;
  568. {
  569.     object r, y;
  570.     int i, j, k,lw;
  571.     object *vp;
  572.  
  573.     cs_check(x);
  574.  
  575.     if (x == OBJNULL) {
  576.         write_str("#<OBJNULL>");
  577.         return;
  578.     }
  579.     if (x->d.m == FREE) {
  580.         write_str("#<FREE OBJECT ");
  581.         write_addr(x);
  582.         write_str(">");
  583.         return;
  584.     }
  585.  
  586.     switch (type_of(x)) {
  587.  
  588.     case t_fixnum:
  589.     {
  590.         object *vsp;
  591.  
  592.         if (PRINTradix && PRINTbase != 10)
  593.             write_base();
  594.         i = fix(x);
  595.         if (i == 0) {
  596.             write_ch('0');
  597.             if (PRINTradix && PRINTbase == 10)
  598.                 write_ch('.');
  599.             break;
  600.         }
  601.         if (i < 0) {
  602.             write_ch('-');
  603.             if (i == 0x80000000) {
  604.                 x = make_bignum(ABS_MOST_NEGS);
  605.                 vs_push(x);
  606.                 i = PRINTradix;
  607.                 PRINTradix = FALSE;
  608.                 write_object(x, level);
  609.                 PRINTradix = i;
  610.                 vs_pop;
  611.                 if (PRINTradix && PRINTbase == 10)
  612.                     write_ch('.');
  613.                 break;
  614.             }
  615.             i = -i;
  616.         }
  617.         vsp = vs_top;
  618.         for (vsp = vs_top;  i != 0;  i /= PRINTbase)
  619.             vs_push(code_char(digit_weight(i%PRINTbase,
  620.                                PRINTbase)));
  621.         while (vs_top > vsp)
  622.             write_ch(char_code((vs_pop)));
  623.         if (PRINTradix && PRINTbase == 10)
  624.             write_ch('.');
  625.         break;
  626.     }
  627.  
  628.     case t_bignum:
  629.     {
  630.         object b;
  631.         object *vsp;
  632.  
  633.         if (PRINTradix && PRINTbase != 10)
  634.             write_base();
  635.         i = big_sign(x);
  636.         if (i == 0) {
  637.             write_ch('0');
  638.             if (PRINTradix && PRINTbase == 10)
  639.                 write_ch('.');
  640.             break;
  641.         }
  642.         if (i < 0) {
  643.             write_ch('-');
  644.             b = big_minus(x);
  645.         } else
  646.             b = copy_big(x);
  647.         vsp = vs_top;
  648.         while (!big_zerop(b))
  649.             vs_check_push(code_char(
  650.                 digit_weight(div_int_big(PRINTbase, b),
  651.                     PRINTbase)));
  652.         while (vs_top > vsp)
  653.             write_ch(char_code((vs_pop)));
  654.         if (PRINTradix && PRINTbase == 10)
  655.             write_ch('.');
  656.         break;
  657.     }
  658.  
  659.     case t_ratio:
  660.         if (PRINTradix) {
  661.             write_base();
  662.             PRINTradix = FALSE;
  663.             write_object(x->rat.rat_num, level);
  664.             write_ch('/');
  665.             write_object(x->rat.rat_den, level);
  666.             PRINTradix = TRUE;
  667.         } else {
  668.             write_object(x->rat.rat_num, level);
  669.             write_ch('/');
  670.             write_object(x->rat.rat_den, level);
  671.         }
  672.         break;
  673.  
  674.     case t_shortfloat:
  675.         r = symbol_value(Vread_default_float_format);
  676.         if (r == Sshort_float)
  677.             write_double((double)sf(x), 0, TRUE);
  678.         else
  679.             write_double((double)sf(x), 'S', TRUE);
  680.         break;
  681.  
  682.     case t_longfloat:
  683.         r = symbol_value(Vread_default_float_format);
  684.         if (r == Ssingle_float ||
  685.             r == Slong_float || r == Sdouble_float)
  686.             write_double(lf(x), 0, FALSE);
  687.         else
  688.             write_double(lf(x), 'F', FALSE);
  689.         break;
  690.  
  691.     case t_complex:
  692.         write_str("#C(");
  693.         write_object(x->cmp.cmp_real, level);
  694.         write_ch(' ');
  695.         write_object(x->cmp.cmp_imag, level);
  696.         write_ch(')');
  697.         break;
  698.  
  699.     case t_character:
  700.         if (!PRINTescape) {
  701.             write_ch(char_code(x));
  702.             break;
  703.         }
  704.         write_str("#\\");
  705.         switch (char_code(x)) {
  706.         case '\r':
  707.             write_str("Return");
  708.             break;
  709.  
  710.         case ' ':
  711.             write_str("Space");
  712.             break;
  713.  
  714.         case '\177':
  715.             write_str("Rubout");
  716.             break;
  717.  
  718.         case '\f':
  719.             write_str("Page");
  720.             break;
  721.  
  722.         case '\t':
  723.             write_str("Tab");
  724.             break;
  725.  
  726.         case '\b':
  727.             write_str("Backspace");
  728.             break;
  729.  
  730.         case '\n':
  731.             write_str("Newline");
  732.             break;
  733.  
  734.         default:
  735.             if (char_code(x) & 0200) {
  736.                 write_ch('\\');
  737.                 i = char_code(x);
  738.                 write_ch(((i>>6)&7) + '0');
  739.                 write_ch(((i>>3)&7) + '0');
  740.                 write_ch(((i>>0)&7) + '0');
  741.             } else if (char_code(x) < 040) {
  742.                 write_ch('^');
  743.                 write_ch(char_code(x) + 0100);
  744.             } else
  745.                 write_ch(char_code(x));
  746.             break;
  747.         }
  748.         break;
  749.  
  750.     case t_symbol:
  751.         if (!PRINTescape) {
  752.             for (lw = 0,i = 0;  i < x->s.s_fillp;  i++) {
  753.                 j = x->s.s_self[i];
  754.                 if (isUpper(j)) {
  755.                                     if (PRINTcase == Kdowncase ||
  756.                                         PRINTcase == Kcapitalize && i!=lw)
  757.                                           j += 'a' - 'A';
  758.                                  } else if (!isLower(j))
  759.                                          lw = i + 1;
  760.                                   write_ch(j);
  761.  
  762.             }
  763.             break;
  764.         }
  765.         if (x->s.s_hpack == Cnil) {
  766.             if (PRINTcircle) {
  767.             for (vp = PRINTvs_top;  vp < PRINTvs_limit;  vp += 2)
  768.                 if (x == *vp) {
  769.                 if (vp[1] != Cnil) {
  770.                     write_ch('#');
  771.                     write_decimal((vp-PRINTvs_top)/2);
  772.                     write_ch('#');
  773.                     return;
  774.                 } else {
  775.                     write_ch('#');
  776.                     write_decimal((vp-PRINTvs_top)/2);
  777.                     write_ch('=');
  778.                     vp[1] = Ct;
  779.                 }
  780.                 }
  781.             }
  782.             if (PRINTgensym)
  783.             write_str("#:");
  784.         } else if (x->s.s_hpack == keyword_package)
  785.             write_ch(':');
  786.         else if (PRINTpackage||find_symbol(x,current_package())!=x
  787.              || intern_flag == 0)
  788.           {
  789.             k = 0;
  790.             for (i = 0;
  791.                  i < x->s.s_hpack->p.p_name->st.st_fillp;
  792.                  i++) {
  793.                 j = x->s.s_hpack->p.p_name
  794.                     ->st.st_self[i];
  795.                 if (to_be_escaped(j))
  796.                     k++;
  797.             }
  798.             if (k > 0)
  799.                 write_ch('|');
  800.              for (lw = 0, i = 0;    
  801.                  i < x->s.s_hpack->p.p_name->st.st_fillp;
  802.                  i++) {
  803.                 j = x->s.s_hpack->p.p_name
  804.                     ->st.st_self[i];
  805.                  if (j == '|' || j == '\\')
  806.                     write_ch('\\');
  807.                                  if (k == 0) {
  808.                                          if (isUpper(j)) {
  809.                                                  if (PRINTcase == Kdowncase ||
  810.                                                      PRINTcase == Kcapitalize && i!=lw)
  811.                                                  j += 'a' - 'A';
  812.                                          } else if (!isLower(j))
  813.                                                  lw = i + 1;
  814.                                  }
  815.                 write_ch(j);
  816.             }
  817.             if (k > 0)
  818.                 write_ch('|');
  819.             if (find_symbol(x, x->s.s_hpack) != x)
  820.                 error("can't print symbol");
  821.             if (PRINTpackage || intern_flag == INTERNAL)
  822.                 write_str("::");
  823.             else if (intern_flag == EXTERNAL)
  824.                 write_ch(':');
  825.             else
  826.             FEerror("Pathological symbol --- cannot print.", 0);
  827.         }
  828.         k = 0;
  829.         if (potential_number_p(x, PRINTbase))
  830.             k++;
  831.         for (i = 0;  i < x->s.s_fillp;  i++) {
  832.             j = x->s.s_self[i];
  833.             if (to_be_escaped(j))
  834.                 k++;
  835.         }
  836.         for (i = 0;  i < x->s.s_fillp;  i++)
  837.             if (x->s.s_self[i] != '.')
  838.                 goto NOT_DOT;
  839.         k++;
  840.  
  841.     NOT_DOT:            
  842.         if (k > 0)
  843.             write_ch('|');
  844.                  for (lw = 0, i = 0;  i < x->s.s_fillp;  i++) {
  845.             j = x->s.s_self[i];
  846.              if (j == '|' || j == '\\')
  847.                 write_ch('\\');
  848.                          if (k == 0) {
  849.                                  if (isUpper(j)) {
  850.                                          if (PRINTcase == Kdowncase ||
  851.                                              PRINTcase == Kcapitalize && i != lw)
  852.                                              j += 'a' - 'A';
  853.                                  } else if (!isLower(j))
  854.                                          lw = i + 1;
  855.                          }
  856.             write_ch(j);
  857.         }
  858.         if (k > 0)
  859.             write_ch('|');
  860.         break;
  861.  
  862.     case t_array:
  863.     {
  864.         int subscripts[ARANKLIM];
  865.         int n, m;
  866.  
  867.         if (!PRINTarray) {
  868.             write_str("#<array ");
  869.             write_addr(x);
  870.             write_str(">");
  871.             break;
  872.         }
  873.         if (PRINTcircle) {
  874.             for (vp = PRINTvs_top;  vp < PRINTvs_limit;  vp += 2)
  875.                 if (x == *vp) {
  876.                 if (vp[1] != Cnil) {
  877.                     write_ch('#');
  878.                     write_decimal((vp-PRINTvs_top)/2);
  879.                     write_ch('#');
  880.                     return;
  881.                 } else {
  882.                     write_ch('#');
  883.                     write_decimal((vp-PRINTvs_top)/2);
  884.                     write_ch('=');
  885.                     vp[1] = Ct;
  886.                     break;
  887.                 }
  888.                 }
  889.         }
  890.         if (PRINTlevel >= 0 && level >= PRINTlevel) {
  891.             write_ch('#');
  892.             break;
  893.         }
  894.         n = x->a.a_rank;
  895.         write_ch('#');
  896.         write_decimal(n);
  897.         write_ch('A');
  898.         if (PRINTlevel >= 0 && level+n >= PRINTlevel)
  899.             n = PRINTlevel - level;
  900.         for (i = 0;  i < n;  i++)
  901.             subscripts[i] = 0;
  902.         m = 0;
  903.         j = 0;
  904.         for (;;) {
  905.             for (i = j;  i < n;  i++) {
  906.                 if (subscripts[i] == 0) {
  907.                     write_ch(MARK);
  908.                     write_ch('(');
  909.                     write_ch(SET_INDENT);
  910.                     if (x->a.a_dims[i] == 0) {
  911.                         write_ch(')');
  912.                         write_ch(UNMARK);
  913.                         j = i-1;
  914.                         k = 0;
  915.                         goto INC;
  916.                     }
  917.                 }
  918.                 if (subscripts[i] > 0)
  919.                     write_ch(INDENT);
  920.                 if (PRINTlength >= 0 &&
  921.                     subscripts[i] >= PRINTlength) {
  922.                     write_str("...)");
  923.                     write_ch(UNMARK);
  924.                     k=x->a.a_dims[i]-subscripts[i];
  925.                     subscripts[i] = 0;
  926.                     for (j = i+1;  j < n;  j++)
  927.                         k *= x->a.a_dims[j];
  928.                     j = i-1;
  929.                     goto INC;
  930.                 }
  931.             }
  932.             if (n == x->a.a_rank) {
  933.                 vs_push(aref(x, m));
  934.                 write_object(vs_head, level+n);
  935.                 vs_pop;
  936.             } else
  937.                 write_ch('#');
  938.             j = n-1;
  939.             k = 1;
  940.  
  941.         INC:
  942.             while (j >= 0) {
  943.                 if (++subscripts[j] < x->a.a_dims[j])
  944.                     break;
  945.                 subscripts[j] = 0;
  946.                 write_ch(')');
  947.                 write_ch(UNMARK);
  948.                 --j;
  949.             }
  950.             if (j < 0)
  951.                 break;
  952.             m += k;
  953.         }
  954.         break;
  955.     }
  956.  
  957.     case t_vector:
  958.         if (!PRINTarray) {
  959.             write_str("#<vector ");
  960.             write_addr(x);
  961.             write_str(">");
  962.             break;
  963.         }
  964.         if (PRINTcircle) {
  965.             for (vp = PRINTvs_top;  vp < PRINTvs_limit;  vp += 2)
  966.                 if (x == *vp) {
  967.                 if (vp[1] != Cnil) {
  968.                     write_ch('#');
  969.                     write_decimal((vp-PRINTvs_top)/2);
  970.                     write_ch('#');
  971.                     return;
  972.                 } else {
  973.                     write_ch('#');
  974.                     write_decimal((vp-PRINTvs_top)/2);
  975.                     write_ch('=');
  976.                     vp[1] = Ct;
  977.                     break;
  978.                 }
  979.                 }
  980.         }
  981.         if (PRINTlevel >= 0 && level >= PRINTlevel) {
  982.             write_ch('#');
  983.             break;
  984.         }
  985.         write_ch('#');
  986.         write_ch(MARK);
  987.         write_ch('(');
  988.         write_ch(SET_INDENT);
  989.         if (x->v.v_fillp > 0) {
  990.             if (PRINTlength == 0) {
  991.                 write_str("...)");
  992.                 write_ch(UNMARK);
  993.                 break;
  994.             }
  995.             vs_push(aref(x, 0));
  996.             write_object(vs_head, level+1);
  997.             vs_pop;
  998.             for (i = 1;  i < x->v.v_fillp;  i++) {
  999.                 write_ch(INDENT);
  1000.                 if (PRINTlength>=0 && i>=PRINTlength){
  1001.                     write_str("...");
  1002.                     break;
  1003.                 }
  1004.                 vs_push(aref(x, i));
  1005.                 write_object(vs_head, level+1);
  1006.                 vs_pop;
  1007.             }
  1008.         }
  1009.         write_ch(')');
  1010.         write_ch(UNMARK);
  1011.         break;
  1012.  
  1013.     case t_string:
  1014.         if (!PRINTescape) {
  1015.             for (i = 0;  i < x->st.st_fillp;  i++)
  1016.                 write_ch(x->st.st_self[i]);
  1017.             break;
  1018.         }
  1019.         write_ch('"');
  1020.         for (i = 0;  i < x->st.st_fillp;  i++) {
  1021.             if (x->st.st_self[i] == '"' ||
  1022.                 x->st.st_self[i] == '\\')
  1023.                 write_ch('\\');
  1024.             write_ch(x->st.st_self[i]);
  1025.         }
  1026.         write_ch('"');
  1027.         break;
  1028.  
  1029.     case t_bitvector:
  1030.         if (!PRINTarray) {
  1031.             write_str("#<bit-vector ");
  1032.             write_addr(x);
  1033.             write_str(">");
  1034.             break;
  1035.         }
  1036.         write_str("#*");
  1037.         for (i = 0;  i < x->bv.bv_fillp;  i++)
  1038.             if (x->bv.bv_self[i/8] & (0200 >> i%8))
  1039.                 write_ch('1');
  1040.             else
  1041.                 write_ch('0');
  1042.         break;
  1043.  
  1044.     case t_cons:
  1045.         if (x->c.c_car == siSsharp_comma) {
  1046.             write_str("#.");
  1047.             write_object(x->c.c_cdr, level);
  1048.             break;
  1049.         }
  1050.         if (PRINTcircle) {
  1051.             for (vp = PRINTvs_top;  vp < PRINTvs_limit;  vp += 2)
  1052.                 if (x == *vp) {
  1053.                 if (vp[1] != Cnil) {
  1054.                     write_ch('#');
  1055.                     write_decimal((vp-PRINTvs_top)/2);
  1056.                     write_ch('#');
  1057.                     return;
  1058.                 } else {
  1059.                     write_ch('#');
  1060.                     write_decimal((vp-PRINTvs_top)/2);
  1061.                     write_ch('=');
  1062.                     vp[1] = Ct;
  1063.                     break;
  1064.                 }
  1065.                 }
  1066.         }
  1067.                 if (PRINTpretty) {
  1068.         if (x->c.c_car == Squote &&
  1069.             type_of(x->c.c_cdr) == t_cons &&
  1070.             x->c.c_cdr->c.c_cdr == Cnil) {
  1071.             write_ch('\'');
  1072.             write_object(x->c.c_cdr->c.c_car, level);
  1073.             break;
  1074.         }
  1075.         if (x->c.c_car == Sfunction &&
  1076.             type_of(x->c.c_cdr) == t_cons &&
  1077.             x->c.c_cdr->c.c_cdr == Cnil) {
  1078.             write_ch('#');
  1079.             write_ch('\'');
  1080.             write_object(x->c.c_cdr->c.c_car, level);
  1081.             break;
  1082.         }
  1083.                 }
  1084.         if (PRINTlevel >= 0 && level >= PRINTlevel) {
  1085.             write_ch('#');
  1086.             break;
  1087.         }
  1088.         write_ch(MARK);
  1089.         write_ch('(');
  1090.         write_ch(SET_INDENT);
  1091.         if (PRINTpretty && x->c.c_car != OBJNULL &&
  1092.             type_of(x->c.c_car) == t_symbol &&
  1093.             (r = getf(x->c.c_car->s.s_plist,
  1094.                       siSpretty_print_format, Cnil)) != Cnil)
  1095.             goto PRETTY_PRINT_FORMAT;
  1096.         for (i = 0;  ;  i++) {
  1097.             if (PRINTlength >= 0 && i >= PRINTlength) {
  1098.                 write_str("...");
  1099.                 break;
  1100.             }
  1101.             y = x->c.c_car;
  1102.             x = x->c.c_cdr;
  1103.             write_object(y, level+1);
  1104.             if (type_of(x) != t_cons) {
  1105.                 if (x != Cnil) {
  1106.                     write_ch(INDENT);
  1107.                     write_str(". ");
  1108.                     write_object(x, level);
  1109.                 }
  1110.                 break;
  1111.             }
  1112.             if (PRINTcircle) {
  1113.               for (vp = PRINTvs_top; vp < PRINTvs_limit; vp += 2)
  1114.                 if (x == *vp) {
  1115.                 if (vp[1] != Cnil) {
  1116.                     write_str(" . #");
  1117.                     write_decimal((vp-PRINTvs_top)/2);
  1118.                     write_ch('#');
  1119.                     goto RIGHT_PAREN;
  1120.                 } else {
  1121.                     write_ch(INDENT);
  1122.                     write_str(". ");
  1123.                     write_object(x, level);
  1124.                     goto RIGHT_PAREN;
  1125.                 }
  1126.                 }
  1127.             }
  1128.             if (i == 0 && y != OBJNULL && type_of(y) == t_symbol)
  1129.                 write_ch(INDENT1);
  1130.             else
  1131.                 write_ch(INDENT);
  1132.         }
  1133.  
  1134.     RIGHT_PAREN:
  1135.         write_ch(')');
  1136.         write_ch(UNMARK);
  1137.         break;
  1138.  
  1139.     PRETTY_PRINT_FORMAT:
  1140.         j = fixint(r);
  1141.         for (i = 0;  ;  i++) {
  1142.             if (PRINTlength >= 0 && i >= PRINTlength) {
  1143.                 write_str("...");
  1144.                 break;
  1145.             }
  1146.             y = x->c.c_car;
  1147.             x = x->c.c_cdr;
  1148.             if (i <= j && y == Cnil)
  1149.                 write_str("()");
  1150.             else
  1151.                 write_object(y, level+1);
  1152.             if (type_of(x) != t_cons) {
  1153.                 if (x != Cnil) {
  1154.                     write_ch(INDENT);
  1155.                     write_str(". ");
  1156.                     write_object(x, level);
  1157.                 }
  1158.                 break;
  1159.             }
  1160.             if (i >= j)
  1161.                 write_ch(INDENT2);
  1162.             else if (i == 0)
  1163.                 write_ch(INDENT1);
  1164.             else
  1165.                 write_ch(INDENT);
  1166.         }
  1167.         goto RIGHT_PAREN;
  1168.  
  1169.     case t_package:
  1170.         write_str("#<");
  1171.         write_object(x->p.p_name, level);
  1172.          write_str(" package>");
  1173.         break;
  1174.  
  1175.     case t_dclosure:
  1176.         write_str("#<compiled-downward-closure ");
  1177.                 write_addr(x);
  1178.         write_str(">");
  1179.     
  1180.       case t_fat_string:
  1181.     {register int ch ;
  1182.      if (!PRINTescape) {
  1183.        for (i = 0;  i < x->st.st_fillp;  i++)
  1184.          write_ch(x->fs.fs_self[i] & 255);
  1185.        break;
  1186.      }
  1187.      write_ch('"');
  1188.      for (i = 0;  i < x->fs.fs_fillp;  i++) {
  1189.        ch =x->fs.fs_self[i] & 255;
  1190.        if (ch == '"' ||
  1191.            ch  == '\\')
  1192.          write_ch('\\');
  1193.        write_ch(ch);
  1194.      }
  1195.      write_ch('"');}
  1196.         break;
  1197.     case t_hashtable:
  1198.         write_str("#<hash-table ");
  1199.         write_addr(x);
  1200.         write_str(">");
  1201.         break;
  1202.  
  1203.     case t_stream:
  1204.         switch (x->sm.sm_mode) {
  1205.         case smm_input:
  1206.             write_str("#<input stream ");
  1207.             write_object(x->sm.sm_object1, level);
  1208.             write_ch('>');
  1209.             break;
  1210.  
  1211.         case smm_output:
  1212.             write_str("#<output stream ");
  1213.             write_object(x->sm.sm_object1, level);
  1214.             write_ch('>');
  1215.             break;
  1216.  
  1217.         case smm_io:
  1218.             write_str("#<io stream ");
  1219.             write_object(x->sm.sm_object1, level);
  1220.             write_ch('>');
  1221.             break;
  1222.  
  1223.         case smm_probe:
  1224.             write_str("#<probe stream ");
  1225.             write_object(x->sm.sm_object1, level);
  1226.             write_ch('>');
  1227.             break;
  1228.  
  1229.         case smm_synonym:
  1230.             write_str("#<synonym stream to ");
  1231.             write_object(x->sm.sm_object0, level);
  1232.             write_ch('>');
  1233.             break;
  1234.  
  1235.         case smm_broadcast:
  1236.             write_str("#<broadcast stream ");
  1237.             write_addr(x);
  1238.             write_str(">");
  1239.             break;
  1240.  
  1241.         case smm_concatenated:
  1242.             write_str("#<concatenated stream ");
  1243.             write_addr(x);
  1244.             write_str(">");
  1245.             break;
  1246.  
  1247.         case smm_two_way:
  1248.             write_str("#<two-way stream ");
  1249.             write_addr(x);
  1250.             write_str(">");
  1251.             break;
  1252.  
  1253.         case smm_echo:
  1254.             write_str("#<echo stream ");
  1255.             write_addr(x);
  1256.             write_str(">");
  1257.             break;
  1258.  
  1259.         case smm_string_input:
  1260.             write_str("#<string-input stream from \"");
  1261.             y = x->sm.sm_object0;
  1262.             j = y->st.st_fillp;
  1263.             for (i = 0;  i < j && i < 16;  i++)
  1264.                 write_ch(y->st.st_self[i]);
  1265.             if (j > 16)
  1266.                 write_str("...");
  1267.             write_str("\">");
  1268.             break;
  1269. #ifdef USER_DEFINED_STREAMS
  1270.             case smm_user_defined:
  1271.             write_str("#<use-define stream");
  1272.             write_addr(x);
  1273.             write_str(">");
  1274.             break;
  1275. #endif
  1276.  
  1277.         case smm_string_output:
  1278.             write_str("#<string-output stream ");
  1279.             write_addr(x);
  1280.             write_str(">");
  1281.             break;
  1282.  
  1283.         default:
  1284.             error("illegal stream mode");
  1285.         }
  1286.         break;
  1287.  
  1288.     case t_random:
  1289.         write_str("#$");
  1290.         y = alloc_object(t_fixnum);
  1291.         fix(y) = x->rnd.rnd_value;
  1292.         vs_push(y);
  1293.         write_object(y, level);
  1294.         vs_pop;
  1295.         break;
  1296.  
  1297.     case t_structure:
  1298.         if (PRINTcircle) {
  1299.             for (vp = PRINTvs_top;  vp < PRINTvs_limit;  vp += 2)
  1300.                 if (x == *vp) {
  1301.                 if (vp[1] != Cnil) {
  1302.                     write_ch('#');
  1303.                     write_decimal((vp-PRINTvs_top)/2);
  1304.                     write_ch('#');
  1305.                     return;
  1306.                 } else {
  1307.                     write_ch('#');
  1308.                     write_decimal((vp-PRINTvs_top)/2);
  1309.                     write_ch('=');
  1310.                     vp[1] = Ct;
  1311.                     break;
  1312.                 }
  1313.                 }
  1314.         }
  1315.         if (PRINTlevel >= 0 && level >= PRINTlevel) {
  1316.             write_ch('#');
  1317.             break;
  1318.         }
  1319.         if (type_of(x->str.str_def) != t_structure)
  1320.             FEwrong_type_argument(Sstructure, x->str.str_def);
  1321.         if (PRINTstructure ||
  1322.             S_DATA(x->str.str_def)->print_function == Cnil)
  1323.               {    
  1324.             write_str("#S");
  1325.             x = structure_to_list(x);
  1326.             vs_push(x);
  1327.             write_object(x, level);
  1328.             vs_pop;
  1329.             break;
  1330.         }
  1331.         call_structure_print_function(x, level);
  1332.         break;
  1333.  
  1334.     case t_readtable:
  1335.         write_str("#<readtable ");
  1336.         write_addr(x);
  1337.         write_str(">");
  1338.         break;
  1339.  
  1340.     case t_pathname:
  1341.         if (1 || PRINTescape) {
  1342.             write_ch('#');
  1343.             vs_push(namestring(x));
  1344.             write_object(vs_head, level);
  1345.             vs_pop;
  1346.         } else {
  1347.             write_str("#<pathname ");
  1348.             write_addr(x);
  1349.             write_str(">");
  1350.         }
  1351.         break;
  1352.     case t_sfun:
  1353.     case t_gfun:
  1354.     case t_vfun:
  1355.     case t_cfun:
  1356.         write_str("#<compiled-function ");
  1357.         if (x->cf.cf_name != Cnil)
  1358.             write_object(x->cf.cf_name, level);
  1359.         else
  1360.             write_addr(x);
  1361.         write_str(">");
  1362.         break;
  1363.  
  1364.     case t_cclosure:
  1365.         write_str("#<compiled-closure ");
  1366.         if (x->cc.cc_name != Cnil)
  1367.             write_object(x->cc.cc_name, level);
  1368.         else
  1369.             write_addr(x);
  1370.         write_str(">");
  1371.         break;
  1372.  
  1373.     case t_spice:
  1374.         write_str("#<\100");
  1375.         for (i = 28;  i >= 0;  i -= 4) {
  1376.             j = ((int)x >> i) & 0xf;
  1377.             if (j < 10)
  1378.                 write_ch('0' + j);
  1379.             else
  1380.                 write_ch('A' + (j - 10));
  1381.         }
  1382.         write_ch('>');
  1383.         break;
  1384.  
  1385.     default:
  1386.         error("illegal type --- cannot print");
  1387.     }
  1388. }
  1389.  
  1390. char travel_push_type[32]; 
  1391.  
  1392. travel_push_object(x)
  1393. object x;
  1394. {
  1395.     enum type t;
  1396.     int i;
  1397.     object *vp;
  1398.  
  1399.     cs_check(x);
  1400.  
  1401. BEGIN:
  1402.     t = type_of(x);
  1403.     if(travel_push_type[(int)t]==0) return;
  1404.     if(t==t_symbol && x->s.s_hpack != Cnil) return;
  1405.  
  1406.     for (vp = PRINTvs_top;  vp < vs_top;  vp += 2)
  1407.         if (x == *vp) {
  1408.             if (vp[1] != Cnil)
  1409.                 return;
  1410.             vp[1] = Ct;
  1411.             return;
  1412.         }
  1413.     vs_check_push(x);
  1414.     vs_check_push(Cnil);
  1415.     if (t == t_array && (enum aelttype)x->a.a_elttype == aet_object)
  1416.         for (i = 0;  i < x->a.a_dim;  i++)
  1417.             travel_push_object(x->a.a_self[i]);
  1418.     else if (t == t_vector && (enum aelttype)x->v.v_elttype == aet_object)
  1419.         for (i = 0;  i < x->v.v_fillp;  i++)
  1420.             travel_push_object(x->v.v_self[i]);
  1421.     else if (t == t_cons) {
  1422.         travel_push_object(x->c.c_car);
  1423.         x = x->c.c_cdr;
  1424.         goto BEGIN;
  1425.     } else if (t == t_structure) {
  1426.         for (i = 0;  i < S_DATA(x->str.str_def)->length;  i++)
  1427.           travel_push_object(structure_ref(x,x->str.str_def,i));
  1428.     }
  1429. }
  1430.  
  1431.  
  1432.  
  1433. setupPRINTcircle(x,dogensyms)
  1434.      object x;
  1435.      int dogensyms;
  1436. {  object *vp,*vq;
  1437.    travel_push_type[(int)t_symbol]=dogensyms;
  1438.    travel_push_type[(int)t_array]=
  1439.        (travel_push_type[(int)t_vector]=PRINTarray);
  1440.    travel_push_object(x);
  1441.    for (vp = vq = PRINTvs_top;  vp < vs_top;  vp += 2)
  1442.      if (vp[1] != Cnil) {
  1443.        vq[0] = vp[0];
  1444.        vq[1] = Cnil;
  1445.        vq += 2;
  1446.      }
  1447.    PRINTvs_limit = vs_top = vq;
  1448.  }
  1449.  
  1450. setupPRINTdefault(x)
  1451. object x;
  1452. {
  1453.     object y;
  1454.     object *vp, *vq;
  1455.  
  1456.     PRINTvs_top = vs_top;
  1457.     PRINTstream = symbol_value(Vstandard_output);
  1458.     if (type_of(PRINTstream) != t_stream) {
  1459.         Vstandard_output->s.s_dbind
  1460.         = symbol_value(Vterminal_io);
  1461.         vs_push(PRINTstream);
  1462.         FEwrong_type_argument(Sstream, PRINTstream);
  1463.     }
  1464.     PRINTescape = symbol_value(Vprint_escape) != Cnil;
  1465.     PRINTpretty = symbol_value(Vprint_pretty) != Cnil;
  1466.     PRINTcircle = symbol_value(Vprint_circle) != Cnil;
  1467.     y = symbol_value(Vprint_base);
  1468.     if (type_of(y) != t_fixnum || fix(y) < 2 || fix(y) > 36) {
  1469.         Vprint_base->s.s_dbind = make_fixnum(10);
  1470.         vs_push(y);
  1471.         FEerror("~S is an illegal PRINT-BASE.", 1, y);
  1472.     } else
  1473.         PRINTbase = fix(y);
  1474.     PRINTradix = symbol_value(Vprint_radix) != Cnil;
  1475.     PRINTcase = symbol_value(Vprint_case);
  1476.     if (PRINTcase != Kupcase && PRINTcase != Kdowncase &&
  1477.         PRINTcase != Kcapitalize) {
  1478.         Vprint_case->s.s_dbind = Kdowncase;
  1479.         vs_push(PRINTcase);
  1480.         FEerror("~S is an illegal PRINT-CASE.", 1, PRINTcase);
  1481.     }
  1482.     PRINTgensym = symbol_value(Vprint_gensym) != Cnil;
  1483.     y = symbol_value(Vprint_level);
  1484.     if (y == Cnil)
  1485.         PRINTlevel = -1;
  1486.     else if (type_of(y) != t_fixnum || fix(y) < 0) {
  1487.         Vprint_level->s.s_dbind = Cnil;
  1488.         vs_push(y);
  1489.         FEerror("~S is an illegal PRINT-LEVEL.", 1, y);
  1490.     } else
  1491.         PRINTlevel = fix(y);
  1492.     y = symbol_value(Vprint_length);
  1493.     if (y == Cnil)
  1494.         PRINTlength = -1;
  1495.     else if (type_of(y) != t_fixnum || fix(y) < 0) {
  1496.         Vprint_length->s.s_dbind = Cnil;
  1497.         vs_push(y);
  1498.         FEerror("~S is an illegal PRINT-LENGTH.", 1, y);
  1499.     } else
  1500.         PRINTlength = fix(y);
  1501.     PRINTarray = symbol_value(Vprint_array) != Cnil;
  1502.     if (PRINTcircle) setupPRINTcircle(x,1);
  1503.     if (PRINTpretty) {
  1504.         qh = qt = qc = 0;
  1505.         isp = iisp = 0;
  1506.         indent_stack[0] = 0;
  1507.         write_ch_fun = writec_queue;
  1508.     } else
  1509.         write_ch_fun = writec_PRINTstream;
  1510.     PRINTpackage = symbol_value(siVprint_package) != Cnil;
  1511.     PRINTstructure = symbol_value(siVprint_structure) != Cnil;
  1512. }
  1513.  
  1514. cleanupPRINT()
  1515. {
  1516.     vs_top = PRINTvs_top;
  1517.     if (PRINTpretty)
  1518.         flush_queue(TRUE);
  1519. }
  1520.  
  1521. write_object_by_default(x)
  1522. object x;
  1523. {
  1524.     setupPRINTdefault(x);
  1525.     write_object(x, 0);
  1526.     flush_stream(PRINTstream);
  1527.     cleanupPRINT();
  1528. }
  1529.  
  1530. terpri_by_default()
  1531. {
  1532.     PRINTstream = symbol_value(Vstandard_output);
  1533.     if (type_of(PRINTstream) != t_stream)
  1534.         FEwrong_type_argument(Sstream, PRINTstream);
  1535.         WRITEC_NEWLINE(PRINTstream);
  1536. }
  1537.  
  1538. bool
  1539. potential_number_p(strng, base)
  1540. object strng;
  1541. int base;
  1542. {
  1543.     int i, l, c, dc;
  1544.     char *s;
  1545.  
  1546.     l = strng->st.st_fillp;
  1547.     if (l == 0)
  1548.         return(FALSE);
  1549.     s = strng->st.st_self;
  1550.     dc = 0;
  1551.     c = s[0];
  1552.     if (digitp(c, base) >= 0)
  1553.         dc++;
  1554.     else if (c != '+' && c != '-' && c != '^' && c != '_')
  1555.         return(FALSE);
  1556.     if (s[l-1] == '+' || s[l-1] == '-')
  1557.         return(FALSE);
  1558.     for (i = 1;  i < l;  i++) {
  1559.         c = s[i];
  1560.         if (digitp(c, base) >= 0) {
  1561.             dc++;
  1562.             continue;
  1563.         }
  1564.         if (c != '+' && c != '-' && c != '/' && c != '.' &&
  1565.             c != '^' && c != '_' &&
  1566.             c != 'e' && c != 'E' &&
  1567.             c != 's' && c != 'S' && c != 'l' && c != 'L')
  1568.             return(FALSE);
  1569.     }
  1570.     if (dc == 0)
  1571.         return(FALSE);
  1572.     return(TRUE);
  1573. }
  1574. @(defun write (x
  1575.            &key ((:stream strm) Cnil)
  1576.             (escape `symbol_value(Vprint_escape)`)
  1577.             (radix `symbol_value(Vprint_radix)`)
  1578.             (base `symbol_value(Vprint_base)`)
  1579.             (circle `symbol_value(Vprint_circle)`)
  1580.             (pretty `symbol_value(Vprint_pretty)`)
  1581.             (level `symbol_value(Vprint_level)`)
  1582.             (length `symbol_value(Vprint_length)`)
  1583.             ((:case cas) `symbol_value(Vprint_case)`)
  1584.             (gensym `symbol_value(Vprint_gensym)`)
  1585.             (array `symbol_value(Vprint_array)`))
  1586.     object *vp, *vq;
  1587. @
  1588.     if (strm == Cnil)
  1589.         strm = symbol_value(Vstandard_output);
  1590.     else if (strm == Ct)
  1591.         strm = symbol_value(Vterminal_io);
  1592.     if (type_of(strm) != t_stream)
  1593.         FEerror("~S is not a stream.", 1, strm);
  1594.     PRINTvs_top = vs_top;
  1595.     PRINTstream = strm;
  1596.     PRINTescape = escape != Cnil;
  1597.     PRINTpretty = pretty != Cnil;
  1598.     PRINTcircle = circle != Cnil;
  1599.     if (type_of(base)!=t_fixnum || fix((base))<2 || fix((base))>36)
  1600.         FEerror("~S is an illegal PRINT-BASE.", 1, base);
  1601.     else
  1602.         PRINTbase = fix((base));
  1603.     PRINTradix = radix != Cnil;
  1604.     PRINTcase = cas;
  1605.     if (PRINTcase != Kupcase && PRINTcase != Kdowncase &&
  1606.         PRINTcase != Kcapitalize)
  1607.         FEerror("~S is an illegal PRINT-CASE.", 1, cas);
  1608.     PRINTgensym = gensym != Cnil;
  1609.     if (level == Cnil)
  1610.         PRINTlevel = -1;
  1611.     else if (type_of(level) != t_fixnum || fix((level)) < 0)
  1612.         FEerror("~S is an illegal PRINT-LEVEL.", 1, level);
  1613.     else
  1614.         PRINTlevel = fix((level));
  1615.     if (length == Cnil)
  1616.         PRINTlength = -1;
  1617.     else if (type_of(length) != t_fixnum || fix((length)) < 0)
  1618.         FEerror("~S is an illegal PRINT-LENGTH.", 1, length);
  1619.     else
  1620.         PRINTlength = fix((length));
  1621.     PRINTarray = array != Cnil;
  1622.     if (PRINTcircle) setupPRINTcircle(x,1);
  1623.     if (PRINTpretty) {
  1624.         qh = qt = qc = 0;
  1625.         isp = iisp = 0;
  1626.         indent_stack[0] = 0;
  1627.         write_ch_fun = writec_queue;
  1628.     } else
  1629.         write_ch_fun = writec_PRINTstream;
  1630.     PRINTpackage = symbol_value(siVprint_package) != Cnil;
  1631.     PRINTstructure = symbol_value(siVprint_structure) != Cnil;
  1632.     write_object(x, 0);
  1633.     cleanupPRINT();
  1634.     flush_stream(PRINTstream);
  1635.     @(return x)
  1636. @)
  1637.  
  1638. @(defun prin1 (obj &optional strm)
  1639. @
  1640.     prin1(obj, strm);
  1641.     @(return obj)
  1642. @)
  1643.  
  1644. @(defun print (obj &optional strm)
  1645. @
  1646.     print(obj, strm);
  1647.     @(return obj)
  1648. @)
  1649.  
  1650. @(defun pprint (obj &optional strm)
  1651. @
  1652.     if (strm == Cnil)
  1653.         strm = symbol_value(Vstandard_output);
  1654.     else if (strm == Ct)
  1655.         strm = symbol_value(Vterminal_io);
  1656.     check_type_stream(&strm);
  1657.         WRITEC_NEWLINE(PRINTstream);
  1658.     setupPRINTdefault(obj);
  1659.     PRINTstream = strm;
  1660.     PRINTescape = TRUE;
  1661.     PRINTpretty = TRUE;
  1662.     qh = qt = qc = 0;
  1663.     isp = iisp = 0;
  1664.     indent_stack[0] = 0;
  1665.     write_ch_fun = writec_queue;
  1666.     write_object(obj, 0);
  1667.     cleanupPRINT();
  1668.     flush_stream(strm);
  1669.     @(return)
  1670. @)
  1671.  
  1672. @(defun princ (obj &optional strm)
  1673. @
  1674.     princ(obj, strm);
  1675.     @(return obj)
  1676. @)
  1677.  
  1678. @(defun write_char (c &optional strm)
  1679. @
  1680.     if (strm == Cnil)
  1681.         strm = symbol_value(Vstandard_output);
  1682.     else if (strm == Ct)
  1683.         strm = symbol_value(Vterminal_io);
  1684.     check_type_character(&c);
  1685.     check_type_stream(&strm);
  1686.     writec_stream(char_code(c), strm);
  1687. /*
  1688.     flush_stream(strm);
  1689. */
  1690.     @(return c)
  1691. @)
  1692.  
  1693. @(defun write_string (strng &o strm &k start end)
  1694.     int s, e, i;
  1695. @
  1696.     get_string_start_end(strng, start, end, &s, &e);
  1697.     if (strm == Cnil)
  1698.         strm = symbol_value(Vstandard_output);
  1699.     else if (strm == Ct)
  1700.         strm = symbol_value(Vterminal_io);
  1701.     check_type_string(&strng);
  1702.     check_type_stream(&strm);
  1703.     for (i = s;  i < e;  i++)
  1704.         writec_stream(strng->st.st_self[i], strm);
  1705.     flush_stream(strm);
  1706.     @(return strng)
  1707. @)
  1708.  
  1709. @(defun write_line (strng &o strm &k start end)
  1710.     int s, e, i;
  1711. @
  1712.     get_string_start_end(strng, start, end, &s, &e);
  1713.     if (strm == Cnil)
  1714.         strm = symbol_value(Vstandard_output);
  1715.     else if (strm == Ct)
  1716.         strm = symbol_value(Vterminal_io);
  1717.     check_type_string(&strng);
  1718.     check_type_stream(&strm);
  1719.     for (i = s;  i < e;  i++)
  1720.         writec_stream(strng->st.st_self[i], strm);
  1721.     WRITEC_NEWLINE(strm);
  1722.     flush_stream(strm);
  1723.     @(return strng)
  1724. @)
  1725.  
  1726. @(defun terpri (&optional strm)
  1727. @
  1728.     terpri(strm);
  1729.     @(return Cnil)
  1730. @)
  1731.  
  1732. @(defun fresh_line (&optional strm)
  1733. @
  1734.     if (strm == Cnil)
  1735.         strm = symbol_value(Vstandard_output);
  1736.     else if (strm == Ct)
  1737.         strm = symbol_value(Vterminal_io);
  1738.     check_type_stream(&strm);
  1739.     if (file_column(strm) == 0)
  1740.         @(return Cnil)
  1741.         WRITEC_NEWLINE(strm);
  1742.     flush_stream(strm);
  1743.     @(return Ct)
  1744. @)
  1745.  
  1746. @(defun finish_output (&o strm)
  1747. @
  1748.     if (strm == Cnil)
  1749.         strm = symbol_value(Vstandard_output);
  1750.     else if (strm == Ct)
  1751.         strm = symbol_value(Vterminal_io);
  1752.     check_type_stream(&strm);
  1753.     flush_stream(strm);
  1754.     @(return Cnil)
  1755. @)
  1756.  
  1757. @(defun force_output (&o strm)
  1758. @
  1759.     if (strm == Cnil)
  1760.         strm = symbol_value(Vstandard_output);
  1761.     else if (strm == Ct)
  1762.         strm = symbol_value(Vterminal_io);
  1763.     check_type_stream(&strm);
  1764.     flush_stream(strm);
  1765.     @(return Cnil)
  1766. @)
  1767.  
  1768. @(defun clear_output (&o strm)
  1769. @
  1770.     if (strm == Cnil)
  1771.         strm = symbol_value(Vstandard_output);
  1772.     else if (strm == Ct)
  1773.         strm = symbol_value(Vterminal_io);
  1774.     check_type_stream(&strm);
  1775.     @(return Cnil)
  1776. @)
  1777.  
  1778. @(defun write_byte (integer binary_output_stream)
  1779. @
  1780.     if (type_of(integer) != t_fixnum)
  1781.         FEerror("~S is not a byte.", 1, integer);
  1782.     check_type_stream(&binary_output_stream);
  1783.     writec_stream(fix(integer), binary_output_stream);
  1784.     @(return integer)
  1785. @)
  1786.  
  1787. init_print()
  1788. {
  1789.  
  1790.         travel_push_type[(int)t_array]=1;
  1791.     travel_push_type[(int)t_vector]=1;
  1792.     travel_push_type[(int)t_structure]=1;
  1793.     travel_push_type[(int) t_cons]=1;
  1794.     if(sizeof(travel_push_type) < (int) t_other)
  1795.       error("travel_push_size to small see print.d");
  1796.     Kupcase = make_keyword("UPCASE");
  1797.     Kdowncase = make_keyword("DOWNCASE");
  1798.     Kcapitalize = make_keyword("CAPITALIZE");
  1799.  
  1800.     Kstream = make_keyword("STREAM");
  1801.     Kescape = make_keyword("ESCAPE");
  1802.     Kpretty = make_keyword("PRETTY");
  1803.     Kcircle = make_keyword("CIRCLE");
  1804.     Kbase = make_keyword("BASE");
  1805.     Kradix = make_keyword("RADIX");
  1806.     Kcase = make_keyword("CASE");
  1807.     Kgensym = make_keyword("GENSYM");
  1808.     Klevel = make_keyword("LEVEL");
  1809.     Klength = make_keyword("LENGTH");
  1810.     Karray = make_keyword("ARRAY");
  1811.  
  1812.     Vprint_escape = make_special("*PRINT-ESCAPE*", Ct);
  1813.     Vprint_pretty = make_special("*PRINT-PRETTY*", Ct);
  1814.     Vprint_circle = make_special("*PRINT-CIRCLE*", Cnil);
  1815.     Vprint_base = make_special("*PRINT-BASE*", make_fixnum(10));
  1816.     Vprint_radix = make_special("*PRINT-RADIX*", Cnil);
  1817.     Vprint_case = make_special("*PRINT-CASE*", Kupcase);
  1818.     Vprint_gensym = make_special("*PRINT-GENSYM*", Ct);
  1819.     Vprint_level = make_special("*PRINT-LEVEL*", Cnil);
  1820.     Vprint_length = make_special("*PRINT-LENGTH*", Cnil);
  1821.     Vprint_array = make_special("*PRINT-ARRAY*", Ct);
  1822.  
  1823.     siVprint_package = make_si_special("*PRINT-PACKAGE*", Cnil);
  1824.     siVprint_structure = make_si_special("*PRINT-STRUCTURE*", Cnil);
  1825.  
  1826.     siSpretty_print_format
  1827.     = make_si_ordinary("PRETTY-PRINT-FORMAT");
  1828.     enter_mark_origin(&siSpretty_print_format);
  1829.  
  1830.     PRINTstream = Cnil;
  1831.     enter_mark_origin(&PRINTstream);
  1832.     PRINTescape = TRUE;
  1833.     PRINTpretty = FALSE;
  1834.     PRINTcircle = FALSE;
  1835.     PRINTbase = 10;
  1836.     PRINTradix = FALSE;
  1837.     PRINTcase = Kupcase;
  1838.     enter_mark_origin(&PRINTcase);
  1839.     PRINTgensym = TRUE;
  1840.     PRINTlevel = -1;
  1841.     PRINTlength = -1;
  1842.     PRINTarray = FALSE;
  1843.  
  1844.     write_ch_fun = writec_PRINTstream;
  1845. }
  1846.  
  1847. object
  1848. princ(obj, strm)
  1849. object obj, strm;
  1850. {
  1851.     if (strm == Cnil)
  1852.         strm = symbol_value(Vstandard_output);
  1853.     else if (strm == Ct)
  1854.         strm = symbol_value(Vterminal_io);
  1855.     if (type_of(strm) != t_stream)
  1856.         FEerror("~S is not a stream.", 1, strm);
  1857.     if (obj == OBJNULL)
  1858.         goto SIMPLE_CASE;
  1859.     switch (type_of(obj)) {
  1860.     case t_symbol:
  1861.         PRINTcase = symbol_value(Vprint_case);
  1862.         PRINTpackage = symbol_value(siVprint_package) != Cnil;
  1863.  
  1864.     SIMPLE_CASE:
  1865.     case t_string:
  1866.     case t_character:
  1867.         PRINTstream = strm;
  1868.         PRINTescape = FALSE;
  1869.         write_ch_fun = writec_PRINTstream;
  1870.         write_object(obj, 0);
  1871.         break;
  1872.  
  1873.     default:
  1874.         setupPRINTdefault(obj);
  1875.         PRINTstream = strm;
  1876.         PRINTescape = FALSE;
  1877.         write_object(obj, 0);
  1878.         cleanupPRINT();
  1879.         break;
  1880.     }
  1881.     return(obj);
  1882. }
  1883.  
  1884. object
  1885. prin1(obj, strm)
  1886. object obj, strm;
  1887. {
  1888.     if (strm == Cnil)
  1889.         strm = symbol_value(Vstandard_output);
  1890.     else if (strm == Ct)
  1891.         strm = symbol_value(Vterminal_io);
  1892.     if (type_of(strm) != t_stream)
  1893.         FEerror("~S is not a stream.", 1, strm);
  1894.     if (obj == OBJNULL)
  1895.         goto SIMPLE_CASE;
  1896.     switch (type_of(obj)) {
  1897.     SIMPLE_CASE:
  1898.     case t_string:
  1899.     case t_character:
  1900.         PRINTstream = strm;
  1901.         PRINTescape = TRUE;
  1902.         write_ch_fun = writec_PRINTstream;
  1903.         write_object(obj, 0);
  1904.         break;
  1905.  
  1906.     default:
  1907.         setupPRINTdefault(obj);
  1908.         PRINTstream = strm;
  1909.         PRINTescape = TRUE;
  1910.         write_object(obj, 0);
  1911.         cleanupPRINT();
  1912.         break;
  1913.     }
  1914.     flush_stream(strm);
  1915.     return(obj);
  1916. }
  1917.  
  1918. object
  1919. print(obj, strm)
  1920. object obj, strm;
  1921. {
  1922.     terpri(strm);
  1923.     prin1(obj,strm);
  1924.     princ(code_char(' '),strm);
  1925.     return(obj);
  1926. }
  1927.  
  1928. object
  1929. terpri(strm)
  1930. object strm;
  1931. {
  1932.     if (strm == Cnil)
  1933.         strm = symbol_value(Vstandard_output);
  1934.     else if (strm == Ct)
  1935.         strm = symbol_value(Vterminal_io);
  1936.     if (type_of(strm) != t_stream)
  1937.         FEerror("~S is not a stream.", 1, strm);
  1938.         WRITEC_NEWLINE(strm);
  1939.     flush_stream(strm);
  1940.     return(Cnil);
  1941. }
  1942.  
  1943. write_string(strng, strm)
  1944. object strng, strm;
  1945. {
  1946.     int i;
  1947.  
  1948.     if (strm == Cnil)
  1949.         strm = symbol_value(Vstandard_output);
  1950.     else if (strm == Ct)
  1951.         strm = symbol_value(Vterminal_io);
  1952.     check_type_string(&strng);
  1953.     check_type_stream(&strm);
  1954.     for (i = 0;  i < strng->st.st_fillp;  i++)
  1955.         writec_stream(strng->st.st_self[i], strm);
  1956.     flush_stream(strm);
  1957. }
  1958.  
  1959. /*
  1960.     THE ULTRA-SPECIAL-DINNER-SERVICE OPTIMIZATION
  1961. */
  1962. princ_str(s, sym)
  1963. char *s;
  1964. object sym;
  1965. {
  1966.     sym = symbol_value(sym);
  1967.     if (sym == Cnil)
  1968.         sym = symbol_value(Vstandard_output);
  1969.     else if (sym == Ct)
  1970.         sym = symbol_value(Vterminal_io);
  1971.     check_type_stream(&sym);
  1972.     writestr_stream(s, sym);
  1973. }
  1974.  
  1975. princ_char(c, sym)
  1976. int c;
  1977. object sym;
  1978. {
  1979.     sym = symbol_value(sym);
  1980.     if (sym == Cnil)
  1981.          sym = symbol_value(Vstandard_output);
  1982.     else if (sym == Ct)
  1983.         sym = symbol_value(Vterminal_io);
  1984.     check_type_stream(&sym);
  1985.     if (c == '\n')
  1986.            {WRITEC_NEWLINE(sym);
  1987.         flush_stream(sym);}
  1988.     else
  1989.     writec_stream(c, sym);
  1990.  
  1991. }
  1992.  
  1993.  
  1994. pp(x)
  1995. object x;
  1996. {
  1997. princ(x,Cnil);
  1998. flush_stream(symbol_value(Vstandard_output));
  1999. }
  2000.  
  2001. set_line_length(n)
  2002. int n;
  2003. {
  2004.   return line_length = n;
  2005. }
  2006.  
  2007. init_print_function()
  2008. {
  2009.     make_function("WRITE", Lwrite);
  2010.     make_function("PRIN1", Lprin1);
  2011.     make_function("PRINT", Lprint);
  2012.     make_function("PPRINT", Lpprint);
  2013.     make_function("PRINC", Lprinc);
  2014.  
  2015.     make_function("WRITE-CHAR", Lwrite_char);
  2016.     make_function("WRITE-STRING", Lwrite_string);
  2017.     make_function("WRITE-LINE", Lwrite_line);
  2018.     make_function("TERPRI", Lterpri);
  2019.     make_function("FRESH-LINE", Lfresh_line);
  2020.     make_function("FINISH-OUTPUT", Lfinish_output);
  2021.     make_function("FORCE-OUTPUT", Lforce_output);
  2022.     make_function("CLEAR-OUTPUT", Lclear_output);
  2023.     siLprint_nans = make_si_special("*PRINT-NANS*",Cnil);
  2024.     make_function("WRITE-BYTE", Lwrite_byte);
  2025.         make_si_sfun("SET-LINE-LENGTH",set_line_length,ARGTYPE1(f_fixnum)
  2026.         | RESTYPE(f_fixnum));
  2027. }
  2028.  
  2029.  
  2030.  
  2031.  
  2032.  
  2033.